; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.

; Compiling primitive procedures and calls to them.

; (primitive-procedure name)  =>  a procedure

(define-compilator 'primitive-procedure syntax-type
  (lambda (node depth frame cont)
    (let ((name (cadr (node-form node)))
          (out-register (get/allocate-out-register frame cont))
          (in-register  (allocate-register frame)))
      (deliver-register-value
        (sequentially
	  (register-indirect-instruction
	    out-register
            (frame-template-index frame)
	    (literal->index frame (primop-closed-template name)))
	  (instruction (enum op false) in-register)
	  (instruction (enum op make-stored-object)
	               out-register
	               (enum stob closure)
	               2 ; # of arguments
	               out-register
	               in-register)
	  (free-register frame in-register))
	out-register frame cont))))


(define (primop-closed-template name)
  (let ((data (primop-closed (get-primop name))))
    (receive (maybe-nargs proc)
	(if (pair? data)
	    (values (car data) (cdr data))
	    (values #f data))
      (let ((frame (make-frame #f	; no parent frame
			       name	; name of primop
			       (or maybe-nargs 0)
					; nargs (needed if template used)
			       maybe-nargs ; need template if nargs
			       #f	; no env
			       #f)))    ; no closure
			                ; no push-registers, as the generators handle this themselves
	(segment->template (proc frame) frame)))))

; --------------------
; Direct primitives.

; The simplest kind of primitive has fixed arity, corresponds to some
; single VM instruction, and takes its arguments in the usual way 
; (first is the return register, then all argument registers)
          
(define (direct-compilator type opcode nargs)
  (lambda (node depth frame cont)
    (receive (code out-register in-registers)
      (compile-to-registers node depth frame cont)
      (deliver-register-value
        (sequentially
          code
          (apply instruction opcode (cons out-register in-registers))
          (apply free-register frame in-registers))
        out-register frame cont))))

(define (closed-register-positions nargs) ; returns a list '(0 1 2 ...)
  (let loop ((i 0))
    (if (= i nargs)
        '()
        (cons i (loop (+ i 1))))))

(define (direct-closed-compilator opcode nargs)
  (lambda (frame) 
    (if (> nargs 0)
        (sequentially
          (lambda-protocol nargs #f #f #f)
          (apply instruction opcode (cons 0 (closed-register-positions nargs)))
          (instruction (enum op return) 0))
      (sequentially
        (lambda-protocol 0 #f #f #f)
        (instruction (enum op push-registers) 1) ; room for return value
        (instruction opcode 0)
        (instruction (enum op return) 0)))))
          

(define (nargs->domain nargs)
  (do ((nargs nargs (- nargs 1))
       (l '() (cons value-type l)))
      ((= nargs 0) (make-some-values-type l))))

(define (get-primop-type id arg-count)
  (or (any (lambda (foo)
	     (if (if (pair? (car foo))
		     (memq id (car foo))
		     (eq? id (car foo)))
		 (cadr foo)
		 #f))
	   primop-types)
      (procedure-type (nargs->domain arg-count)
		      value-type
		      #t)))

; Types for various primops.

(define primop-types
  `((eq?
     ,(proc (value-type value-type) boolean-type))
    ((number? integer? rational? real? complex? char? eof-object? port?)
     ,(proc (value-type) boolean-type))
    (exact?
     ,(proc (number-type) boolean-type))
    (exact->inexact
     ,(proc (number-type) inexact-type))
    (inexact->exact
     ,(proc (number-type) exact-type))
    ((exp log sin cos tan asin acos sqrt)
     ,(proc (number-type) number-type))
    ((floor)
     ,(proc (real-type) integer-type))
    ((real-part imag-part angle magnitude)
     ,(proc (complex-type) real-type))
    ((numerator denominator)
     ,(proc (rational-type) integer-type))
    ((make-polar make-rectangular)
     ,(proc (real-type real-type) complex-type))
    ((quotient remainder)
     ,(proc (integer-type integer-type) integer-type))
    ((bitwise-not)
     ,(proc (exact-integer-type) exact-integer-type))
    ((arithmetic-shift)
     ,(proc (exact-integer-type exact-integer-type)
	    exact-integer-type))
    (open-channel
     ;; Can return #f
     ,(proc (string-type value-type exact-integer-type boolean-type) value-type))
    (cons
     ,(proc (value-type value-type) pair-type))
    (intern
     ,(proc (string-type) symbol-type))
    (make-weak-pointer
     ,(proc (value-type) value-type))))


; Can't do I/O until the meta-types interface exports input-port-type and
; output-port-type.

; Define all the primitives that correspond to opcodes in the obvious way.


(do ((opcode 0 (+ opcode 1)))
    ((= opcode op-count))
  (let* ((arg-specs (vector-ref opcode-arg-specs opcode))
         (arg-specs (filter (lambda (spec)   ; filter the registers specs, so we get the arg count 
         		      (and (not (eq? spec 'out-register))
         		           (not (eq? spec 'in-register))))
         		    arg-specs))    		       
         (name (enumerand->name opcode op)))        
    (cond ((memq name '(call-external-value call-external-value-2 return-from-callback
			return-from-interrupt resume-native-poll return 
			return-from-exception return-from-native-exception
			resume-interrupted-opcode-to-byte-code resume-interrupted-call-to-native-code
			binary-reduce1 binary-reduce2 binary-comparison-reduce1 binary-comparison-reduce2)))
	  ((memq name '(+ * - / = < > <= >=
			bitwise-ior bitwise-xor bitwise-and
			make-string closed-apply with-continuation
			encode-char/us-ascii
			char->utf char->utf! utf->char utf->char!
			push-false push pop)))			
			
          ((null? arg-specs)
           (let ((type (proc () value-type)))
             (define-compiler-primitive name type
               (direct-compilator type opcode 0)
               (direct-closed-compilator opcode 0))))
          ((not (number? (car arg-specs))))
          (else
           (let* ((nargs (car arg-specs))
                  (type (get-primop-type name nargs)))
             (define-compiler-primitive name type
               (direct-compilator type opcode nargs)
               (direct-closed-compilator opcode nargs)))))))

; --------------------
; Simple primitives are executed using a fixed instruction or
; instruction sequence.

; op-maker must be (lambda (out-reg in-regs) code-segment)
;
(define (define-simple-primitive name type op-maker)
  (let ((winner? (fixed-arity-procedure-type? type)))
    (let ((nargs (if winner?
                     (procedure-type-arity type)
                     (assertion-violation 'define-simple-primitive
					  "n-ary simple primitive?!" name type))))
      (define-compiler-primitive name type
        (simple-compilator op-maker)
        (simple-closed-compilator nargs op-maker)))))

(define (simple-compilator op-maker)
  (lambda (node depth frame cont)
    (receive (code out-register in-registers) (compile-to-registers node depth frame cont)
      (deliver-register-value
        (sequentially
          code
          (op-maker out-register in-registers)
          (apply free-register frame in-registers))
        out-register frame cont))))

(define (simple-closed-compilator nargs op-maker)
  (lambda (frame) 
    (if (> nargs 0)
        (sequentially
          (lambda-protocol nargs #f #f #f)
          (op-maker 0 (closed-register-positions nargs))
          (instruction (enum op return) 0))
      (sequentially
        (lambda-protocol 0 #f #f #f)
        (instruction (enum op push-registers) 1) ; room for return value
        (op-maker 0 '())
        (instruction (enum op return) 0)))))


(define (define-stob-predicate name stob-name)
  (define-simple-primitive name
    (proc (value-type) boolean-type)
    (lambda (out-register in-registers)
      (instruction (enum op stored-object-has-type?) out-register (car in-registers)    
                   (name->enumerand stob-name stob)))))

(define-stob-predicate 'byte-vector? 'byte-vector)
(define-stob-predicate 'double? 'double)
(define-stob-predicate 'string? 'string)

; Making doubles

(let ((:double (sexp->type ':double #t)))
  (define-simple-primitive 'make-double (proc () :double)
    (lambda (out-register in-registers)
      (instruction (enum op make-double) out-register))))

; Define primitives for record-like stored objects (e.g. pairs).

(define (define-data-struct-primitives name predicate maker . slots)
  (let* ((def-prim (lambda (name type op . more)
                     (define-simple-primitive name type
                       (lambda (out-register in-registers)
                         (apply instruction op out-register (append in-registers more))))))                          
         (type-byte (name->enumerand name stob))
         (type (sexp->type (symbol-append ': name) #t)))
    (define-stob-predicate predicate name)
    (if maker
        (let* ((nargs (length slots)))
          (define-simple-primitive maker
            (procedure-type (nargs->domain nargs) type #t)
            (lambda (out-register in-registers)
              (apply instruction (enum op make-stored-object) out-register type-byte nargs in-registers)))))                    
    (do ((i 0 (+ i 1))
         (slots slots (cdr slots)))
        ((null? slots))
      (let ((slot (car slots)))
        (if (car slot)
	    (def-prim (car slot)
	      (proc (type) value-type)
	      (enum op stored-object-ref) type-byte i))
        (if (not (null? (cdr slot)))
	    (begin
	      (if (not (eq? (cadr slot)
			    'cell-set!))
		  (def-prim (cadr slot)
		    (proc (type value-type) unspecific-type)
		    (enum op stored-object-set!) type-byte i 0))
	      (if (car slot)
		  (def-prim (symbol-append 'provisional- (car slot))
		    (proc (type) value-type)
		    (enum op stored-object-logging-ref) type-byte i))
	      (def-prim (symbol-append 'provisional- (cadr slot))
		(proc (type value-type) unspecific-type)
		(enum op stored-object-set!) type-byte i 1)))))))

(for-each (lambda (stuff)
            (apply define-data-struct-primitives stuff))
          stob-data)

; CELL-SET! is special because we want to capture names for the debugging data.
; Other than using NAMED-CONT when it can for compiling the value this is the
; same as all the other accessors.

(let ((op-maker (lambda (out-register in-registers)
                  (instruction (enum op stored-object-set!)
                               out-register
                               (car in-registers)
                               (cadr in-registers)
                               (enum stob cell)
                               0      ; index
                               0))))  ; non provisional
  (define-compiler-primitive 'cell-set!
    (proc ((sexp->type ':cell #t) value-type) unspecific-type)
    (lambda (node depth frame cont)
      (let* ((args         (cdr (node-form node)))
             (out-register (get/allocate-out-register frame cont))
             (arg1-cont    (register-cont node 1))
             (arg2-cont    (if (name-node? (car args))
                               (named-register-cont (node-form (car args)))
                               (register-cont node 2))))
        (deliver-register-value
          (sequentially
            (compile (car args) depth frame arg1-cont)
            (compile (cadr args) depth frame arg2-cont)
            (op-maker out-register
                      (list (register-cont-register arg1-cont)
                            (register-cont-register arg2-cont)))
            (clear-register-cont frame arg1-cont)
            (clear-register-cont frame arg2-cont))
          out-register frame cont)))
    (simple-closed-compilator 2 op-maker)))

; Define primitives for vector-like stored objects.

(define (define-vector-primitives name element-type)
  (let* ((type-byte (name->enumerand name stob))
         (def-prim (lambda (name type op . more)
                     (define-simple-primitive name type
                       (lambda (out-register in-registers)
                         (apply instruction op out-register (append in-registers (list type-byte) more))))))                      
         (type (sexp->type (symbol-append ': name) #t)))
    (define-stob-predicate (symbol-append name '?) name)
    (if (not (eq? name 'vector))  ; 2nd arg to make-vector is optional
	(def-prim (symbol-append 'make- name)
	  (proc (exact-integer-type element-type) type)
	  (enum op make-vector-object)))
    (def-prim (symbol-append name '- 'length)
      (proc (type) exact-integer-type)
      (enum op stored-object-length))
    (def-prim (symbol-append name '- 'ref)
      (proc (type exact-integer-type) element-type)
      (enum op stored-object-indexed-ref)
      0)		; do not log in the proposal
    (def-prim (symbol-append name '- 'set!)
      (proc (type exact-integer-type element-type) unspecific-type)
      (enum op stored-object-indexed-set!)
      0)))		; do not log in the proposal

(for-each (lambda (name)
            (define-vector-primitives name value-type))
          '(vector record continuation extended-number template))

(define-syntax define-more-vector-primitives
  (syntax-rules ()
    ((define-vector-primitives
       (ref ref-op)
       (set set-op)
       vector-type elt-type (more ...))
     (begin
       (define-simple-primitive 'ref
	 (proc (vector-type exact-integer-type) elt-type)
	 (lambda (out-register in-registers)
	   (instruction (enum op ref-op) out-register (car in-registers) (cadr in-registers) more ...)))
       (define-simple-primitive 'set
	 (proc (vector-type exact-integer-type elt-type) unspecific-type)
	 (lambda (out-register in-registers)
	   (instruction (enum op set-op) out-register (car in-registers) (cadr in-registers) (caddr in-registers) more ...)))))))

; Vector ref and set! that use the current proposal's logs.

(define-more-vector-primitives
  (provisional-vector-ref  stored-object-indexed-ref)
  (provisional-vector-set! stored-object-indexed-set!)
  vector-type
  value-type
  ((enum stob vector) 1))
       
(define-more-vector-primitives
  (provisional-byte-vector-ref  byte-vector-logging-ref)
  (provisional-byte-vector-set! byte-vector-logging-set!)
  value-type
  exact-integer-type
  ())
       
; Checked-record-ref and friends.

(let ((record-type (sexp->type ':record #t))
      (copy-type (proc (value-type exact-integer-type
		        value-type exact-integer-type
			exact-integer-type)
		       unspecific-type))
      (make-op-maker 
        (lambda (op log-byte)
          (lambda (out-register in-registers)
            (apply instruction op out-register (append in-registers (list log-byte)))))))   
                                
  (define-simple-primitive 'checked-record-ref
    (proc (record-type value-type exact-integer-type) value-type)
    (make-op-maker (enum op checked-record-ref) 0))

  (define-simple-primitive 'provisional-checked-record-ref
    (proc (record-type value-type exact-integer-type) value-type)
    (make-op-maker (enum op checked-record-ref) 1))

  (define-simple-primitive 'checked-record-set!
    (proc (record-type value-type exact-integer-type value-type)
	  unspecific-type)
    (make-op-maker (enum op checked-record-set!) 0))

  (define-simple-primitive 'provisional-checked-record-set!
    (proc (record-type value-type exact-integer-type value-type)
	  unspecific-type)
    (make-op-maker (enum op checked-record-set!) 1))

  (define-simple-primitive 'copy-bytes! copy-type
    (make-op-maker (enum op copy-bytes!) 0))
    
  (define-simple-primitive 'attempt-copy-bytes! copy-type
    (make-op-maker (enum op copy-bytes!) 1)))


; SIGNAL-CONDITION is the same as TRAP.

(define-simple-primitive 'signal-condition (proc (value-type) unspecific-type)
  (lambda (out-register in-registers)
    (instruction (enum op trap) out-register (car in-registers))))


; with-continuation

(define-compiler-primitive 'with-continuation
  (proc (escape-type (proc () any-values-type #f)) any-arguments-type)
  (lambda (node depth frame cont)
    (receive (code in-registers) (compile-arguments-to-registers node (cdr (node-form node)) depth frame)
      (sequentially
        code
        (instruction (enum op with-continuation)
                     (car in-registers)
                     (cadr in-registers))
        (apply free-register frame in-registers))))
  (lambda (frame) 
    (sequentially
      (lambda-protocol 2 #f #f #f)
      (instruction (enum op with-continuation) 0 1))))


; (primitive-catch (lambda (cont) ...))

(define-compiler-primitive 'primitive-catch
  (proc ((proc (escape-type) any-values-type #f)) any-values-type)
  ;; (primitive-catch (lambda (cont) ...))
  (lambda (node depth frame cont)
    (let* ((exp (node-form node))
           (args (cdr exp))
           (cont-register (allocate-register frame))
           (proc-cont (register-cont node 1)))
        (receive (before depth label after)
	    (maybe-push-continuation depth frame cont (car args) #f)
	  (sequentially before	              	            
	                (instruction (enum op current-cont) cont-register)                        
                        (compile (car args) depth frame proc-cont)
		        (register-call-instruction (register-cont-register proc-cont)
		                                   depth frame label (list cont-register))
		        (free-register frame cont-register)
		        (clear-register-cont frame proc-cont)		        
		        after))))        
  (lambda (frame)
    (sequentially (lambda-protocol 1 #f #f #f)
                  (instruction (enum op push-registers) 1) ; will be the top of stack so its the argument to the call
                  (instruction (enum op current-cont) 1)		  
                  (call-instruction 0 1 (+ (full-frame-size frame) 1) frame #f)))) ; one argument, no return label


; (call-with-values producer consumer)

; Optimization 1 (not done):
;  If consumer is a lambda then generate it in-line with its own protocol as
; the return protocol for the producer.  Once you have the values on the stack
; it can be treated as a redex.
; 
; Optimization 2 (not done):
;  If both the consumer and producer are lambdas then do as above except
; that the producer gets a special multiple-values continuation.  There
; could be a VALUES opcode that moved its arguments down to the appropriate
; point and then jumped, or the jump could be a separate instruction.
;  The jump target would have a protocol to allow tail calls within the
; producer as well.
;

(define-compiler-primitive 'call-with-values
  (proc ((proc () any-values-type #f)
         any-procedure-type)
        any-values-type)
  (lambda (node depth frame cont)
    (let ((args (cdr (node-form node)))
          (producer-cont (register-cont node 1)))
      (receive (ignore-before ignore-depth c-label c-after)
	  (maybe-push-continuation depth frame cont (cadr args) #t)
	(receive (p-before p-depth p-label p-after)
	    (push-continuation-no-protocol (+ depth 1)
					   frame
					   (car args)
					   (ignore-values-cont node 1)
					   #t) 
	  (sequentially (push-arguments node (list (cadr args)) 2 depth frame) ; push the consumer as part of the continuation
			p-before
			(compile (car args)
				 p-depth
				 frame
				 producer-cont)
			(instruction-using-label (enum op call)
						 p-label
						 (register-cont-register producer-cont)
						 0)
	                (clear-register-cont frame producer-cont)
			p-after
			(cwv-continuation-protocol c-label)
			c-after)))))
    (lambda (frame)
      (receive (before depth label after)
	  (push-continuation-no-protocol 2 frame #f (ignore-values-cont #f #f) #t) 
	(sequentially (lambda-protocol 2 #f #f #f)            
                      before  ; the consumer is already on the top of the stack
		      (using-optional-label (enum op call) label 0 0) ; the producer is in accessible as register 0
		      after
                      (cwv-continuation-protocol #f)))))


; Is NODE a lambda with a null variable list.

(define (thunk-node? node)
  (and (or (lambda-node? node)
	   (flat-lambda-node? node))
       (null? (cadr (node-form node)))))

; Works for both normal and flat lambdas.

(define (thunk-body node)
  (last (node-form node)))

; Return a non-flat version of the possibly-flat lambda NODE's form.

(define (unflatten-form node)
  (let ((form (node-form node)))
    (if (flat-lambda-node? node)
	`(lambda ,(cadr form) ,(cadddr form))
	form)))

; --------------------
; Variable-arity primitives

(define (define-n-ary-compiler-primitive name result-type min-nargs
                                         compilator closed)
  (define-compiler-primitive name
        (if result-type
            (procedure-type any-arguments-type result-type #f)
            #f)
    (if compilator
        (n-ary-primitive-compilator name min-nargs compilator)
        compile-unknown-call)
    closed))

(define (n-ary-primitive-compilator name min-nargs compilator)
  (lambda (node depth frame cont)
    (let ((exp (node-form node)))
      (if (>= (length (cdr exp)) min-nargs)
          (compilator node depth frame cont)
          (begin (warning 'n-ary-primitive-compilator
			  "too few arguments to primitive"
			  (schemify node))
                 (compile-unknown-call node depth frame cont))))))

; APPLY wants the arguments on the stack
; with procedure, final list in registers

(define-compiler-primitive 'apply
  (proc (any-procedure-type &rest value-type) any-values-type)
  (n-ary-primitive-compilator 'apply 2
    (lambda (node depth frame cont)    
      (let* ((exp (node-form node))     ; (apply proc arg1 arg2 arg3 rest)
             (proc (cadr exp))
             (rest+args (reverse (cddr exp))) ; (rest arg3 arg2 arg1)
             (rest (car rest+args))
             (args (reverse (cdr rest+args)))   ; (arg1 arg2 arg3)
             (stack-nargs (length args))
             (proc-cont (register-cont node 1))
             (rest-cont (register-cont node (- (length exp) 1))))
	(receive (before depth label after)
	    (maybe-push-continuation depth frame cont node #t)
	  (sequentially before	                	                
	                (push-arguments node args 2 depth frame)
	                (compile rest (+ depth stack-nargs) frame rest-cont)
	                (compile proc (+ depth stack-nargs) frame proc-cont)
			;; Operand is the proc-register, rest-register + number of non-final arguments
			(using-optional-label (enum op apply)
					      label
					      (register-cont-register proc-cont)
					      (register-cont-register rest-cont)
					      (high-byte stack-nargs)
					      (low-byte stack-nargs))		        
 		        (clear-register-cont frame rest-cont)
 		        (clear-register-cont frame proc-cont)
			after)))))
  (lambda (frame)
    (sequentially (nary-primitive-protocol 2)
                  (instruction (enum op closed-apply)))))

; (values value1 value2 ...)
;
; Okay, this is the second half of the deal.
;  - if tail-recursive, then just push the arguments followed by the opcode
;  - if ignore-values continuation, then evaluate the arguments without
;    doing any pushes in between
;  - if register-cont, then there had better be only one value
;  - that's it for now, given that there is no special CALL-WITH-VALUES
;    continuation

(define-n-ary-compiler-primitive 'values #f 0
  (lambda (node depth frame cont)
    (let* ((args (cdr (node-form node)))
           (nargs (length args)))
      (cond ((= 1 nargs)		; +++ (we miss some errors this way)
	     (compile (car args)
		      depth
		      frame
		      cont))
	    ((return-cont? cont)
	     (depth-check! frame (+ depth nargs))
	     (sequentially (push-arguments node args 1 depth frame)
			   (instruction (enum op values)
					(high-byte nargs)
					(low-byte nargs))))
	    ((ignore-values-cont? cont)
	     (evaluate-arguments-for-effect args node depth frame))
	    ((register-cont? cont)
	     (generate-trap depth
			    frame
			    cont
			    (if (= nargs 0)
				"returning no arguments where one is expected"
				(string-append "returning "
					       (number->string nargs)
					       " arguments where one is expected"))
			    (schemify node)))
	    (else
	     (assertion-violation 'values
				  "unknown compiler continuation for VALUES" cont)))))
  (lambda (frame)
    (sequentially (nary-primitive-protocol 0)
		  (instruction (enum op closed-values)))))


(define (evaluate-arguments-for-effect args node depth frame)
  (do ((args args (cdr args))
       (i 1 (+ i 1))
       (code empty-segment
	     (sequentially code
			   (compile (car args)
				    depth
				    frame
				    (ignore-values-cont node i)))))
      ((null? args)
       code)))

; To ensure that these opcodes are always followed the same code sequence and a return, they only
; exist in a closed-compiled version

; (call-external-value external-routine arg ...)

(define-n-ary-compiler-primitive 'call-external-value value-type 1
  #f 
  (lambda (frame)
    (sequentially (nary-primitive-protocol 1)
                  (instruction (enum op call-external-value))
                  (instruction (enum op pop) 0) ; result is on top of the stack
                  (instruction (enum op return) 0))))

(define-n-ary-compiler-primitive 'call-external-value-2 value-type 1
  #f 
  (lambda (frame)
    (sequentially (nary-primitive-protocol 1)
                  (instruction (enum op call-external-value-2))
                  (instruction (enum op pop) 0)
                  (instruction (enum op return) 0))))

; return-from-callback

(define-compiler-primitive 'return-from-callback 
  (get-primop-type 'return-from-callback 2)
  compile-unknown-call
  (lambda (frame)
    (sequentially (lambda-protocol 2 #f #f #f)
                  (instruction (enum op return-from-callback))
                  (instruction (enum op pop) 0)
                  (instruction (enum op return) 0))))



(let ((n-ary-constructor
        (lambda (name type type-byte)
	  (define-n-ary-compiler-primitive name type 0
	    (lambda (node depth frame cont)
	      (let* ((args  (cdr (node-form node)))
	             (nargs (length args)))
	       (receive (code out-register in-registers) (compile-to-registers node depth frame cont)
	         (deliver-register-value
	           (sequentially
	             code
	             (apply instruction (enum op make-stored-object)
	                    out-register
	                    type-byte
	                    nargs
	                    in-registers)
	             (apply free-register frame in-registers))
	           out-register frame cont))))
	    (lambda (frame)
              (sequentially
                (nary-primitive-protocol 0)
		(instruction (enum op closed-make-stored-object) type-byte)
		(instruction (enum op return) 0)))))))
  (n-ary-constructor 'vector vector-type (enum stob vector))
  (n-ary-constructor 'record #f (enum stob record)))

; READ-BYTE, PEEK-BYTE and WRITE-BYTE

(let ((define-byte/char-io
	(lambda (id opcode type)
	  (define-compiler-primitive id
	    type
	    (lambda (node depth frame cont)
	      (if (node-ref node 'type-error)
		  (compile-unknown-call node depth frame cont)
		  (let ((args (cdr (node-form node)))
		        (out-register (get/allocate-out-register frame cont)))
		    (deliver-register-value
		      (if (null? args)
		          (sequentially
		            (instruction (enum op false) out-register)
		            (instruction opcode out-register out-register))
		          (let ((arg-cont (register-cont node 1)))
		            (sequentially
		              (compile (car args) depth frame arg-cont)
		              (instruction opcode out-register (register-cont-register arg-cont))
		              (clear-register-cont frame arg-cont))))
		      out-register frame cont))))
            (lambda (frame)
              (make-dispatch-protocol
	        ; Zero arguments
                (sequentially (instruction (enum op push-false)) ; use current-port	        
	                      (instruction opcode 0 0)
			      (instruction (enum op return) 0))
		; One argument
		(sequentially (instruction opcode 0 0) ; use port on stack
			      (instruction (enum op return) 0))
	       empty-segment
	       empty-segment))))))
  (define-byte/char-io 'read-byte
    (enum op read-byte)
    (proc (&opt value-type) value-type))
  (define-byte/char-io 'peek-byte
    (enum op peek-byte)
    (proc (&opt value-type) value-type))
  (define-byte/char-io 'read-char
    (enum op read-char)
    (proc (&opt value-type) value-type))
  (define-byte/char-io 'peek-char
    (enum op peek-char)
    (proc (&opt value-type) value-type)))

(let ((define-byte/char-io
	(lambda (id opcode type)
	  (define-compiler-primitive id
	    type
	    (lambda (node depth frame cont)
	      (if (node-ref node 'type-error)
		  (compile-unknown-call node depth frame cont)
		  (let ((args         (cdr (node-form node)))
		        (out-register (get/allocate-out-register frame cont))
		        (arg1-cont    (register-cont node 1))
		        (arg2-cont    (register-cont node 2)))
		    (deliver-register-value
		      (sequentially
		        (compile (car args) depth frame arg1-cont)
		        (if (null? (cdr args))
		          (let ((register (allocate-register frame)))
		            (set-register-cont-register! arg2-cont register)
		            (sequentially
		              (instruction (enum op false) register)
		              (instruction opcode out-register
		                                  (register-cont-register arg1-cont)
		                                  register))) ; false is the second parameter		                                  
		          (sequentially
		            (compile (cadr args) depth frame arg2-cont)
		            (instruction opcode out-register
		                                (register-cont-register arg1-cont)
		                                (register-cont-register arg2-cont))))
		        (clear-register-cont frame arg1-cont)
		        (clear-register-cont frame arg2-cont))
		      out-register frame cont))))
            (lambda (frame)
              (make-dispatch-protocol
                empty-segment
                ; One argument
                (sequentially (instruction (enum op push-false))
			      (instruction opcode 0 0 1)
			      (instruction (enum op return) 0))
                ; Two arguments
                (sequentially (instruction opcode 0 0 1)
			      (instruction (enum op return) 0))
                empty-segment))))))
  (define-byte/char-io 'write-byte
    (enum op write-byte)
    (proc (integer-type &opt value-type) unspecific-type))
  (define-byte/char-io 'write-char
    (enum op write-char)
    (proc (char-type &opt value-type) unspecific-type)))

; Timings in 0.47 to figure out how to handle the optional ports.
; 
; reading 10**6 characters (no buffer underflow)
; empty loop    time:  3.44 seconds
; read-char     time:  3.68 seconds    ; special primitive, exceptions
; xread-char    time:  9.04 seconds    ; special primitive, no exceptions
; xxread-char   time: 14.05 seconds    ; no special primitive
; Currently, looping through a 10**6 character file takes 1.51 seconds or
; 2.50 seconds if you count the number of characters.

;----------------
; Variable-arity arithmetic primitives.

; +, *, bitwise-... take any number of arguments.
  
(let ((define+*
	(lambda (id opcode identity type)
	  (define-compiler-primitive id
	    (proc (&rest type) type)
	    (lambda (node depth frame cont)
	      (if (node-ref node 'type-error)
		  (compile-unknown-call node depth frame cont)
		  (let ((args (cdr (node-form node))))
		    (cond ((null? args)
		           (if (ignore-values-cont? cont)
		               empty-segment		               
		               (let ((out-register (get/allocate-out-register frame cont)))
		                 (deliver-register-value
		                   (integer-literal-instruction out-register identity) ; identity is 0 or 1
		                   out-register frame cont))))
			  ((null? (cdr args))
			   (call-on-arg-and-id opcode identity (car args)
					       node depth frame cont))
			  (else
			   (call-on-args opcode args node depth frame cont))))))
	    (lambda (frame)
              (make-dispatch-protocol
                ; No arguments
                (sequentially (instruction (enum op push-registers) 1)
                              (integer-literal-instruction 0 identity)
			      (instruction (enum op return) 0))
                ; One argument
                (sequentially (instruction (enum op push-registers) 1)
                              (integer-literal-instruction 1 identity)                	      
			      (instruction opcode 0 0 1)
			      (instruction (enum op return) 0))
                ; Two arguments
                (sequentially
                  (instruction opcode 0 0 1)
                  (instruction (enum op return) 0))
                ; More than two arguments
                (sequentially
                  (instruction (enum op binary-reduce1))
                  (instruction opcode 0 0 1)
 	          (instruction (enum op binary-reduce2))
                  (instruction (enum op return) 0))))))))
  (define+* '+ (enum op +) 0 number-type)
  (define+* '* (enum op *) 1 number-type)
  (define+* 'bitwise-ior (enum op bitwise-ior) 0 exact-integer-type)
  (define+* 'bitwise-xor (enum op bitwise-xor) 0 exact-integer-type)
  (define+* 'bitwise-and (enum op bitwise-and) -1 exact-integer-type))

; = and < and so forth take two or more arguments.

(let ((define=<
	(lambda (id opcode type)
	  (define-compiler-primitive id
	    (proc (type type &rest type) boolean-type)
	    (lambda (node depth frame cont)
	      (if (node-ref node 'type-error)
		  (compile-unknown-call node depth frame cont)
		  (let ((args (cdr (node-form node))))
		    (if (= (length args) 2)
			(call-on-args opcode args node depth frame cont)
			(compile-unknown-call node depth frame cont)))))
	    (lambda (frame)
              (make-dispatch-protocol
	        empty-segment
                empty-segment
                ; Two arguments
                (sequentially (instruction opcode 0 0 1)			      
			      (instruction (enum op return) 0))
                ; More than two arguments 
                (sequentially (instruction (enum op binary-comparison-reduce1))
                  	      (instruction opcode 2 0 1)
                  	      (instruction (enum op binary-comparison-reduce2))    
			      (instruction (enum op return) 2))))))))      
  (define=< '= (enum op =) real-type)
  (define=< '< (enum op <) real-type)
  (define=< '> (enum op >) real-type)
  (define=< '<= (enum op <=) real-type)
  (define=< '>= (enum op >=) real-type)
  (define=< 'char<? (enum op char<?) char-type)
  (define=< 'char=? (enum op char=?) char-type)
  (define=< 'string=? (enum op string=?) string-type))

; Returns code to apply OPCODE to IDENTITY and ARGUMENT.

(define (call-on-arg-and-id opcode identity argument node depth frame cont)
  (let ((out-register (get/allocate-out-register frame cont))
        (arg-cont     (register-cont node 1)))
    (deliver-register-value
      (sequentially
        (integer-literal-instruction out-register identity) ; identity is 0 or 1
	(compile argument depth frame arg-cont)
	(instruction opcode out-register out-register (register-cont-register arg-cont))
	(clear-register-cont frame arg-cont))
      out-register frame cont)))     
      

(define (call-on-args opcode args node depth frame cont)
  (let* ((out-register (get/allocate-out-register frame cont))
         (arg1-cont    (register-cont node 1))
         (arg2-cont    (register-cont node 2))
         (start (sequentially
                  (compile (car args) depth frame arg1-cont)
                  (compile (cadr args) depth frame arg2-cont)
                  (instruction opcode
                               out-register
                               (register-cont-register arg1-cont)
                               (register-cont-register arg2-cont)))))
    (free-register frame
                   (register-cont-register arg1-cont)
                   (register-cont-register arg2-cont))
    (let loop ((args (cddr args)) (i 3) (code start))
      (if (null? args)
          (deliver-register-value code out-register frame cont)
          (let ((arg-cont (register-cont node i)))
            (loop (cdr args) (+ i 1)
              (sequentially code
                (compile (car args) depth frame arg-cont)
                (instruction opcode out-register out-register (register-cont-register arg-cont))
                (clear-register-cont frame arg-cont))))))))
                     

(define op/unspecific (get-operator 'unspecific))
(define op/literal (get-operator 'literal))

; -, and / take one or two arguments.

(let ((define-one-or-two
	(lambda (id opcode default-arg)
	  (define-compiler-primitive id
            (proc (number-type &opt number-type) number-type)
	    (lambda (node depth frame cont)
	      (if (node-ref node 'type-error)
		  (compile-unknown-call node depth frame cont)
		  (let* ((args (cdr (node-form node)))
			 (args (if (null? (cdr args))
				   (list (make-node op/literal default-arg)
					 (car args))
				   args))
		         (out-register (get/allocate-out-register frame cont)))
		    (receive (code in-registers) (compile-arguments-to-registers node args depth frame)		      		    
		      (deliver-register-value
		        (sequentially
		          code
		          (apply instruction opcode out-register in-registers)
		          (apply free-register frame in-registers))
                        out-register frame cont)))))
	    (lambda (frame)
              (make-dispatch-protocol
	        empty-segment
                ; One argument
                (sequentially (instruction (enum op push-registers) 1)
                              (integer-literal-instruction 1 default-arg)			      
			      (instruction opcode 0 1 0) ; the default arg is the first parameter
			      (instruction (enum op return) 0))
                ; Two arguments
                (sequentially (instruction opcode 0 0 1)
			      (instruction (enum op return) 0))
                empty-segment))))))
  (define-one-or-two '- (enum op -) 0)
  (define-one-or-two '/ (enum op /) 1))

; ATAN also takes one or two arguments, but the meanings are disjoint.

(define-compiler-primitive 'atan
  (proc (number-type &opt number-type) number-type)
  (lambda (node depth frame cont)
    (if (node-ref node 'type-error)
	(compile-unknown-call node depth frame cont)
	(let* ((args   (cdr (node-form node)))
	       (opcode (if (= (length args) 1) (enum op atan1) (enum op atan2))))
	  (receive (code out-register in-registers)
	    (compile-to-registers node depth frame cont)
	    (deliver-register-value
	      (sequentially
		code
		(apply instruction opcode (cons out-register in-registers))
		(apply free-register frame in-registers))
	      out-register frame cont)))))
  (lambda (frame)
    (make-dispatch-protocol
      empty-segment
      ; One argument
      (sequentially (instruction (enum op atan1) 0 0)
		    (instruction (enum op return) 0))
      ; Two arguments
      (sequentially (instruction (enum op atan2) 0 0 1)
		    (instruction (enum op return) 0))
      empty-segment)))

; make-vector and make-string take one or two arguments.

(let ((define-one-or-two
	(lambda (id op-maker default-arg default-arg-maker type)
	  (define-compiler-primitive id
	    type
	    (lambda (node depth frame cont)
	      (if (node-ref node 'type-error)
		  (compile-unknown-call node depth frame cont)
		  (let* ((args (cdr (node-form node)))
			 (args (if (null? (cdr args))
				   (list (car args) default-arg)
				   args))
		         (out-register (get/allocate-out-register frame cont)))
		    (receive (code in-registers) (compile-arguments-to-registers node args depth frame)
		      (deliver-register-value
		        (sequentially
		          code
		          (apply op-maker out-register in-registers)
		          (apply free-register frame in-registers))
		        out-register frame cont)))))
	    (lambda (frame)
              (make-dispatch-protocol
	        empty-segment
		; One argument
                (sequentially (instruction (enum op push-registers) 1)
                              (default-arg-maker 1)
                              (op-maker 0 0 1)
			      (instruction (enum op return) 0))
                ; Two arguments
                (sequentially (op-maker 0 0 1) 
			      (instruction (enum op return) 0))
                empty-segment))))))
  (define-one-or-two 'make-vector   
    (lambda (out in1 in2)
      (instruction (enum op make-vector-object) out in1 in2 (enum stob vector)))  
    (make-node op/unspecific '(unspecific))
    (lambda (out)
      (instruction (enum op unspecific) out))
    (proc (number-type &opt value-type) vector-type))
  (define-one-or-two 'make-string
    (lambda (out in1 in2)
      (instruction (enum op make-string) out in1 in2))     
    (make-node op/literal #\?)
    (lambda (out)
      (sequentially
        (integer-literal-instruction out (char->ascii #\?))
        (instruction (enum op scalar-value->char) out out)))
    (proc (number-type &opt char-type) string-type)))


; Text encoding/decoding

; These return multiple values, which is why this is more work.

(let ((define-encode/decode
	(lambda (name type arg-count retval-count
		      regular bang)
	  (let ((depth-inc (max (- arg-count 1) retval-count)))
	    (define-compiler-primitive name type
	      (lambda (node depth frame cont)
		(depth-check! frame (+ depth depth-inc))
		(let ((args (cdr (node-form node))))
		  (cond
		   ((or (return-cont? cont) (ignore-values-cont? cont))
		    (receive (code in-registers) 
		      (compile-arguments-to-registers node args depth frame)
		      (sequentially
		        code
		        (if (return-cont? cont)
		            (apply instruction regular in-registers) ; acts as return with values, so no deliver-register-value here!
		            (apply instruction bang in-registers))    ; no output register
		        (apply free-register frame in-registers))))
		   ((register-cont? cont)
		    (generate-trap depth
				   frame
				   cont
				   (string-append "returning " 
						  (number->string retval-count)
						  " arguments where one is expected")
				   (schemify node)))
		   (else
		    (assertion-violation 'define-encode/decode
					 "unknown compiler continuation" (enumerand->name regular op) cont)))))
	      (lambda (frame)
	        (sequentially
	          (lambda-protocol arg-count #f #f #f)
	          (apply instruction regular (closed-register-positions arg-count)))) ; acts as return opcode 
	      )))))

  (define-encode/decode 'char->utf
    (proc (exact-integer-type char-type value-type exact-integer-type exact-integer-type)
	  (make-some-values-type (list boolean-type value-type)))
    5 2
    (enum op char->utf) (enum op char->utf!))

  (define-encode/decode 'utf->char
    (proc (exact-integer-type value-type exact-integer-type exact-integer-type)
	  (make-some-values-type (list value-type value-type)))
    4 2
    (enum op utf->char) (enum op utf->char!)))

